home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Collection of Tools & Utilities
/
Collection of Tools and Utilities.iso
/
graphic
/
tpega.zip
/
SURFACE.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1986-02-05
|
7KB
|
267 lines
program surface;
{taken from page 184 PC tech Journal Vol. 3 No. 11}
var
xctr, yctr : real;
{ *** NOTE: The following definitions are part of my math library. They may or
may not be needed, depending on which function you put into function f(x,y).
You may want to omit these lines if you have your own functions library to
put in here. For the sake of convenience, it would be wise to put these
definitions in a file and include it at compile time with the i directive. *}
{ This program has been modified for the EGA by Kent Cedola, if you like a
copy of all of the EGA graphic routines for Turbo Pascal, send Disk and SASE
to Kent Cedola, 2015 Meadow Lake Court, Norfolk, VA 23518 * FREE * }
const
Tiny: real = 1E-38;
{$I GPPARMS.P }
{$I GPINIT.P }
{$I GPTERM.P }
{$I GPCOLOR.P }
{$I GPMOVE.P }
{$I GPPLOT.P }
{$I GPLINE.P }
function ArcSin(trig : real) : real;
begin
ArcSin := ArcTan(trig / sqrt(1 - sqr(trig)));
end; { function ArcSin(trig : real) }
function ArcCos(trig : real) : real;
begin
ArcCos := ArcTan(Sqrt(1 - Sqr(trig)) / trig);
end; { function ArcCos(trig : real) }
function Tan(trig : real) : real;
begin
Tan := Sin(trig) / Cos(trig);
end;
function E(x,y : real) : real; {raises x to the y pwr -- x^y in basic}
begin
E := Exp(y * Ln(x));
end; { function E(x,y }
{ *** END OF MATH LIBRARY ***}
{Define function to be graphed - z=f(x,y)}
function f(x,y:real): real;
var
x1, y1 : real;
begin
x1:=abs(x-xctr); y1:=abs(y-yctr);
{ Function: Enter your own below. Notice that all others must be commented out
1. Pond Ripples
2. Stretched Planar Curve
3. Rippled Plane
4. Inverse Cone
5. Egg Carton
6. Pond Ripples 2
f := sin(sqrt(x1*x1+y1*y1));
f := sqrt(100-sqrt(x1*x1+y1*y1));
f := exp(-(x*y+y*y)/90)*cos((x*x+y*y)/40);
f := sqrt(x1*x1+y1*y1); }
f := sin(x)+cos(y); {
f := Sin(sqrt(x1*x1+y1*y1))/(sqrt(x1*x1+y1*y1)+tiny);
f := sin(1/x+1/(x*y));}
end; { function f(x,y:real) }
Const
xdiv = 40; {number of subdivisions of each axis}
ydiv = 60;
xeye = 100; {eye position}
yeye = 3; {xeye and yeye should be positive}
zeye = 8;
var
i,j : integer;
xmin, xmax,
ymin, ymax,
zmin, zmax,
xdif, ydif, zdif : real;
p, q : array[0..xdiv,0..ydiv] of integer;
y, z : array[0..xdiv,0..ydiv] of real;
{input extreme values for x and y}
procedure Input_Domain;
begin
write('Enter smallest value of x '); readln(xmin);
write('Enter largest value of x '); readln(xmax); xdif:= xmax - xmin;
Write('Enter smallest value of y '); readln(ymin);
write('Enter largest value of y '); readln(ymax); ydif:= ymax - ymin;
xctr:= xmin + xdif/2; yctr:= ymin + ydif/2;
end; { procedure Input_Domain }
{evaluate function at grid points and project to view plane}
procedure Evaluate_and_Project;
var
xtemp, xtemp1, xtemp2,
ytemp, ytemp1,
ztemp,
xavg, yavg : real;
begin
xavg:= (xmax+xmin)/2; yavg:=(ymax+ymin)/2;
for i:=0 to xdiv do
for j:=0 to ydiv do begin
xtemp:=xmin+i*xdif/xdiv;
ytemp:=ymin+j*ydif/ydiv;
ztemp:=f(xtemp,ytemp);
xtemp1:=xeye - xtemp;
ytemp1:=yeye - ytemp;
y[i,j]:= (xeye - xavg)*(xeye*ytemp - yeye*xtemp) /
((xeye - xavg)*xtemp1+(yeye-yavg)*ytemp1);
if y[i,j] <> yeye then
z[i,j] := zeye + (zeye - ztemp)*(Y[i,j] - yeye)/ytemp1
else begin
xtemp2 := yeye*(yavg - yeye) / (xeye - xavg);
z[i,j] := zeye + (zeye - ztemp)*(xtemp2 - xeye) / xtemp1;
end;
end;
end; { procedure Evaluate_and_Project }
{determine projected extrema}
procedure Find_Extrema;
var
ytemp, ztemp : real;
begin
ymax:= y[0,0]; ymin:=ymax;
zmax:= z[0,0]; zmin:=zmax;
for i:=0 to xdiv do
for j:=0 to ydiv do begin
ytemp:=y[i,j];
ztemp:=z[i,j];
if ytemp>ymax then ymax:=ytemp;
if ytemp<ymin then ymin:=ytemp;
if ztemp>zmax then zmax:=ztemp;
if ztemp<zmin then zmin:=ztemp;
end;
end; { procedure Find_Extrema }
procedure Scale_to_Screen;
var
dy, dz : real;
begin
dy:=(Ymax-ymin)/639; dz:=(Zmax - zmin)/349;
for i:=0 to xdiv do
for j:=0 to ydiv do begin
p[i,j]:=round((y[i,j] - ymin) / dy);
q[i,j]:=349 - round((z[i,j] - zmin) / dz);
end;
end; { procedure Scale_to_Screen }
{exchange coordinates of two points}
procedure Swap(var x1,y1,x2,y2:integer);
var
temp:integer;
begin
temp:=x1; x1:=x2; x2:=temp;
temp:=y1; y1:=y2; y2:=temp;
end; { procedure Swap(var x1,y1,x2,y2:integer) }
{draws blank horizontal line}
procedure Line(x0,x1,y:integer);
begin
GPCOLOR(Black);
GPMOVE(x0,y);
GPLINE(x1,y);
end; { procedure Line(x0,x1,y:integer) }
{blanks triangle}
procedure Triblank(x0,y0,x1,y1,x2,y2:integer);
var
x3, x4,
dx1, dx2, dy1, dy2,
inc1, inc2,
nx1, nx2 : integer;
procedure Blank(y:integer);
begin
while y0<y do begin
nx1:=nx1+dx1;
if nx1>dy1 then
repeat
x3:=x3+inc1;
nx1:=nx1-dy1;
until nx1<=dy1;
nx2:=nx2+dx2;
if nx2>dy2 then
repeat
x4:=x4+inc2;
nx2:=nx2 - dy2;
until nx2<=dy2;
y0:=y0+1;
line(x3,x4,y0);
end;
end; { procedure Blank(y:integer) }
begin
if y1<y0 then swap(x0,y0,x1,y1);
if y2<y0 then swap(x0,y0,x2,y2);
if y2<y1 then swap(x1,y1,x2,y2);
dy1:=y1-y0; dy2:=y2-y0;
if x1<x0 then inc1:=-1 else inc1:=1;
if x2<x0 then inc2:=-1 else inc2:=1;
dx1:=abs(x1-x0); dx2:=abs(x2-x0);
x3:=x0; x4:=x0;
nx1:=dy1 div 2; nx2:=dy2 div 2;
blank(y1);
if x2<x1 then inc1:=-1 else inc1:=1;
x3:=x1; dy1:=y2-y1;
dx1:=abs(x1-x2); nx1:=dy1 div 2;
blank(y2);
end; { procedure Triblank(x0,y0,x1,y1,x2,y2:integer) }
{Draws box with blank interior}
procedure DrawBox(x1,y1,x2,y2,x3,y3,x4,y4 : integer);
begin
triblank(x1,y1,x2,y2,x3,y3);
triblank(x2,y2,x3,y3,x4,y4);
GPCOLOR(Green);
GPMOVE(x1,y1); GPLINE(x2,y2);
GPMOVE(x1,y1); GPLINE(x3,y3);
GPMOVE(x2,y2); GPLINE(x4,y4);
GPMOVE(x3,y3); GPLINE(x4,y4);
end; { procedure DrawBox(x1,y1,x2,y2,x3,y3,x4,y4 : integer) }
{Draws surface}
procedure Graph;
var
x1,x2,x3,x4,y1,y2,y3,y4 : integer;
begin
GPINIT;
for i:=0 to xdiv-1 do
for j:=0 to ydiv-1 do begin
x1:=p[i,j]; x2:=p[i+1,j];
x3:=p[i,j+1]; x4:=p[i+1,j+1];
y1:=q[i,j]; y2:=q[i+1,j];
y3:=q[i,j+1]; y4:=q[i+1,j+1];
drawBox(x1,y1,x2,y2,x3,y3,x4,y4);
end;
end; { procedure Graph }
begin
GPPARMS;
GPINIT;
GPCOLOR(Green);
input_Domain;
Evaluate_and_Project;
Find_Extrema;
Scale_to_Screen;
Graph;
repeat until keypressed;
GPTERM;
end.